home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Module / Pluggable / Object.pm
Encoding:
Perl POD Document  |  2009-06-26  |  8.9 KB  |  322 lines
  1. package Module::Pluggable::Object;
  2.  
  3. use strict;
  4. use File::Find ();
  5. use File::Basename;
  6. use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
  7. use Carp qw(croak carp);
  8. use Devel::InnerPackage;
  9. use Data::Dumper;
  10. use vars qw($VERSION);
  11.  
  12. $VERSION = '3.6';
  13.  
  14.  
  15. sub new {
  16.     my $class = shift;
  17.     my %opts  = @_;
  18.  
  19.     return bless \%opts, $class;
  20.  
  21. }
  22.  
  23.  
  24. sub plugins {
  25.         my $self = shift;
  26.  
  27.         # override 'require'
  28.         $self->{'require'} = 1 if $self->{'inner'};
  29.  
  30.         my $filename   = $self->{'filename'};
  31.         my $pkg        = $self->{'package'};
  32.  
  33.         # automatically turn a scalar search path or namespace into a arrayref
  34.         for (qw(search_path search_dirs)) {
  35.             $self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_});
  36.         }
  37.  
  38.  
  39.  
  40.  
  41.         # default search path is '<Module>::<Name>::Plugin'
  42.         $self->{'search_path'} = ["${pkg}::Plugin"] unless $self->{'search_path'}; 
  43.  
  44.  
  45.         #my %opts = %$self;
  46.  
  47.  
  48.         # check to see if we're running under test
  49.         my @SEARCHDIR = exists $INC{"blib.pm"} && $filename =~ m!(^|/)blib/! ? grep {/blib/} @INC : @INC;
  50.  
  51.         # add any search_dir params
  52.         unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'};
  53.  
  54.  
  55.         my @plugins = $self->search_directories(@SEARCHDIR);
  56.  
  57.         # push @plugins, map { print STDERR "$_\n"; $_->require } list_packages($_) for (@{$self->{'search_path'}});
  58.         
  59.         # return blank unless we've found anything
  60.         return () unless @plugins;
  61.  
  62.  
  63.         # exceptions
  64.         my %only;   
  65.         my %except; 
  66.         my $only;
  67.         my $except;
  68.  
  69.         if (defined $self->{'only'}) {
  70.             if (ref($self->{'only'}) eq 'ARRAY') {
  71.                 %only   = map { $_ => 1 } @{$self->{'only'}};
  72.             } elsif (ref($self->{'only'}) eq 'Regexp') {
  73.                 $only = $self->{'only'}
  74.             } elsif (ref($self->{'only'}) eq '') {
  75.                 $only{$self->{'only'}} = 1;
  76.             }
  77.         }
  78.         
  79.  
  80.         if (defined $self->{'except'}) {
  81.             if (ref($self->{'except'}) eq 'ARRAY') {
  82.                 %except   = map { $_ => 1 } @{$self->{'except'}};
  83.             } elsif (ref($self->{'except'}) eq 'Regexp') {
  84.                 $except = $self->{'except'}
  85.             } elsif (ref($self->{'except'}) eq '') {
  86.                 $except{$self->{'except'}} = 1;
  87.             }
  88.         }
  89.  
  90.  
  91.         # remove duplicates
  92.         # probably not necessary but hey ho
  93.         my %plugins;
  94.         for(@plugins) {
  95.             next if (keys %only   && !$only{$_}     );
  96.             next unless (!defined $only || m!$only! );
  97.  
  98.             next if (keys %except &&  $except{$_}   );
  99.             next if (defined $except &&  m!$except! );
  100.             $plugins{$_} = 1;
  101.         }
  102.  
  103.         # are we instantiating or requring?
  104.         if (defined $self->{'instantiate'}) {
  105.             my $method = $self->{'instantiate'};
  106.             return map { ($_->can($method)) ? $_->$method(@_) : () } keys %plugins;
  107.         } else { 
  108.             # no? just return the names
  109.             return keys %plugins;
  110.         }
  111.  
  112.  
  113. }
  114.  
  115. sub search_directories {
  116.     my $self      = shift;
  117.     my @SEARCHDIR = @_;
  118.  
  119.     my @plugins;
  120.     # go through our @INC
  121.     foreach my $dir (@SEARCHDIR) {
  122.         push @plugins, $self->search_paths($dir);
  123.     }
  124.  
  125.     return @plugins;
  126. }
  127.  
  128.  
  129. sub search_paths {
  130.     my $self = shift;
  131.     my $dir  = shift;
  132.     my @plugins;
  133.  
  134.     my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
  135.  
  136.  
  137.     # and each directory in our search path
  138.     foreach my $searchpath (@{$self->{'search_path'}}) {
  139.         # create the search directory in a cross platform goodness way
  140.         my $sp = catdir($dir, (split /::/, $searchpath));
  141.  
  142.         # if it doesn't exist or it's not a dir then skip it
  143.         next unless ( -e $sp && -d _ ); # Use the cached stat the second time
  144.  
  145.         my @files = $self->find_files($sp);
  146.  
  147.         # foreach one we've found 
  148.         foreach my $file (@files) {
  149.             # untaint the file; accept .pm only
  150.             next unless ($file) = ($file =~ /(.*$file_regex)$/); 
  151.             # parse the file to get the name
  152.             my ($name, $directory, $suffix) = fileparse($file, $file_regex);
  153.  
  154.             $directory = abs2rel($directory, $sp);
  155.  
  156.             # If we have a mixed-case package name, assume case has been preserved
  157.             # correctly.  Otherwise, root through the file to locate the case-preserved
  158.             # version of the package name.
  159.             my @pkg_dirs = ();
  160.             if ( $name eq lc($name) || $name eq uc($name) ) {
  161.                 my $pkg_file = catfile($sp, $directory, "$name$suffix");
  162.                 open PKGFILE, "<$pkg_file" or die "search_paths: Can't open $pkg_file: $!";
  163.                 my $in_pod = 0;
  164.                 while ( my $line = <PKGFILE> ) {
  165.                     $in_pod = 1 if $line =~ m/^=\w/;
  166.                     $in_pod = 0 if $line =~ /^=cut/;
  167.                     next if ($in_pod || $line =~ /^=cut/);  # skip pod text
  168.                     next if $line =~ /^\s*#/;               # and comments
  169.                     if ( $line =~ m/^\s*package\s+(.*::)?($name)\s*;/i ) {
  170.                         @pkg_dirs = split /::/, $1;
  171.                         $name = $2;
  172.                         last;
  173.                     }
  174.                 }
  175.                 close PKGFILE;
  176.             }
  177.  
  178.             # then create the class name in a cross platform way
  179.             $directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/);       # remove volume
  180.             my @dirs = ();
  181.             if ($directory) {
  182.                 ($directory) = ($directory =~ /(.*)/);
  183.                 @dirs = grep(length($_), splitdir($directory)) 
  184.                     unless $directory eq curdir();
  185.                 for my $d (reverse @dirs) {
  186.                     my $pkg_dir = pop @pkg_dirs; 
  187.                     last unless defined $pkg_dir;
  188.                     $d =~ s/\Q$pkg_dir\E/$pkg_dir/i;  # Correct case
  189.                 }
  190.             } else {
  191.                 $directory = "";
  192.             }
  193.             my $plugin = join '::', $searchpath, @dirs, $name;
  194.  
  195.             next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i;
  196.  
  197.             my $err = $self->handle_finding_plugin($plugin);
  198.             carp "Couldn't require $plugin : $err" if $err;
  199.              
  200.             push @plugins, $plugin;
  201.         }
  202.  
  203.         # now add stuff that may have been in package
  204.         # NOTE we should probably use all the stuff we've been given already
  205.         # but then we can't unload it :(
  206.         push @plugins, $self->handle_innerpackages($searchpath) unless (exists $self->{inner} && !$self->{inner});
  207.     } # foreach $searchpath
  208.  
  209.     return @plugins;
  210. }
  211.  
  212. sub handle_finding_plugin {
  213.     my $self   = shift;
  214.     my $plugin = shift;
  215.  
  216.     return unless (defined $self->{'instantiate'} || $self->{'require'}); 
  217.     $self->_require($plugin);
  218. }
  219.  
  220. sub find_files {
  221.     my $self         = shift;
  222.     my $search_path  = shift;
  223.     my $file_regex   = $self->{'file_regex'} || qr/\.pm$/;
  224.  
  225.  
  226.     # find all the .pm files in it
  227.     # this isn't perfect and won't find multiple plugins per file
  228.     #my $cwd = Cwd::getcwd;
  229.     my @files = ();
  230.     { # for the benefit of perl 5.6.1's Find, localize topic
  231.         local $_;
  232.         File::Find::find( { no_chdir => 1, 
  233.                            wanted => sub { 
  234.                              # Inlined from File::Find::Rule C< name => '*.pm' >
  235.                              return unless $File::Find::name =~ /$file_regex/;
  236.                              (my $path = $File::Find::name) =~ s#^\\./##;
  237.                              push @files, $path;
  238.                            }
  239.                       }, $search_path );
  240.     }
  241.     #chdir $cwd;
  242.     return @files;
  243.  
  244. }
  245.  
  246. sub handle_innerpackages {
  247.     my $self = shift;
  248.     my $path = shift;
  249.     my @plugins;
  250.  
  251.  
  252.     foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
  253.         my $err = $self->handle_finding_plugin($plugin);
  254.         #next if $err;
  255.         #next unless $INC{$plugin};
  256.         push @plugins, $plugin;
  257.     }
  258.     return @plugins;
  259.  
  260. }
  261.  
  262.  
  263. sub _require {
  264.     my $self = shift;
  265.     my $pack = shift;
  266.     local $@;
  267.     eval "CORE::require $pack";
  268.     return $@;
  269. }
  270.  
  271.  
  272. 1;
  273.  
  274. =pod
  275.  
  276. =head1 NAME
  277.  
  278. Module::Pluggable::Object - automatically give your module the ability to have plugins
  279.  
  280. =head1 SYNOPSIS
  281.  
  282.  
  283. Simple use Module::Pluggable -
  284.  
  285.     package MyClass;
  286.     use Module::Pluggable::Object;
  287.     
  288.     my $finder = Module::Pluggable::Object->new(%opts);
  289.     print "My plugins are: ".join(", ", $finder->plugins)."\n";
  290.  
  291. =head1 DESCRIPTION
  292.  
  293. Provides a simple but, hopefully, extensible way of having 'plugins' for 
  294. your module. Obviously this isn't going to be the be all and end all of
  295. solutions but it works for me.
  296.  
  297. Essentially all it does is export a method into your namespace that 
  298. looks through a search path for .pm files and turn those into class names. 
  299.  
  300. Optionally it instantiates those classes for you.
  301.  
  302. =head1 AUTHOR
  303.  
  304. Simon Wistow <simon@thegestalt.org>
  305.  
  306. =head1 COPYING
  307.  
  308. Copyright, 2006 Simon Wistow
  309.  
  310. Distributed under the same terms as Perl itself.
  311.  
  312. =head1 BUGS
  313.  
  314. None known.
  315.  
  316. =head1 SEE ALSO
  317.  
  318. L<Module::Pluggable>
  319.  
  320. =cut 
  321.  
  322.